home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1993…ch: Other People's Memory / ADC Developer CD (1993-03) (''Other People's Memory'')_iso / Dev.CD Mar 93.iso / Development Platforms / LISP Related / LISP Goodies / McCartney-library 1.1 / CODE / views / select-icon-button.lisp < prev   
Encoding:
Text File  |  1992-09-02  |  5.1 KB  |  154 lines  |  [TEXT/CCL2]
  1. ;;; select-icon-button.lisp
  2. ;;;
  3. ;;; Paul McCartney, Spring 1992
  4. ;;;
  5. ;;; Copyright © 1992 Paul McCartney.  All Rights Reserved.
  6. ;;; 
  7. ;;; Washington University Medical Informatics Training Program
  8. ;;;
  9. ;;; DESCRIPTION:
  10. ;;;
  11. ;;; Select icon button is a specialized dialog item to display a
  12. ;;; button with a selected icon.  When the button is pressed, a pop
  13. ;;; up view is displayed presenting a palette of icons to choose from.
  14. ;;; The user can choose an icon by moving the mouse to it.  The selected
  15. ;;; icon becomes the button's face when the mouse is released.
  16. ;;;
  17. ;;; USE:
  18. ;;;
  19. ;;; select-icon-button  - dialog item object class
  20. ;;;     :selected-icon  - number or nickname of an icon
  21. ;;;       (see pop-up-select-icon-view for more info)
  22. ;;;
  23. ;;; selected-icon      - return the number or nickname of the selected icon 
  24. ;;; set-selected-icon  - set the number or nickname of the selected icon  
  25. ;;;
  26. ;;; HISTORY:
  27. ;;;
  28. ;;; 7/23/92 Created.  - PM
  29. ;;;
  30.  
  31. (in-package :ccl)
  32.  
  33. (require :pop-up-select-icon-view)
  34. (require :GWorld-view-extensions)
  35.  
  36. (export '(select-icon-button selected-icon set-selected-icon)
  37.         :ccl)
  38.  
  39.  
  40. (defclass select-icon-button (pop-up-select-icon-view dialog-item)
  41.   ((selected-icon :initarg :selected-icon :accessor icon-num)
  42.    )
  43.   (:default-initargs
  44.     :selected-icon 0
  45.     )
  46. )
  47.  
  48.  
  49. (defmethod initialize-instance ((view select-icon-button) &rest initargs)
  50.   (apply #'call-next-method view initargs)
  51.   (set-view-size view 
  52.                  (+ (point-h (i-size view)) 12) 
  53.                  (+ (point-v (i-size view)) 6))
  54.   (if (symbolp (icon-num view))
  55.     (set-selected-icon view (icon-num view)))
  56. )
  57.  
  58.  
  59. (defmethod view-draw-contents ((view select-icon-button))
  60.   (let ((right (point-h (view-size view)))
  61.         (bottom (point-v (view-size view))))
  62.     (with-GWorld-no-colorization (view 0 0 right bottom)
  63.       (with-back-color (or (part-color view :background) *white-color*)
  64.         (with-fore-color (or (part-color view :shadow) *black-color*)
  65.           (rlet ((r :rect :topleft #@(2 2) :bottomright (view-size view)))
  66.             (#_PaintRect r)))
  67.         (rlet ((r :rect 
  68.                   :topleft #@(0 0) 
  69.                   :bottomright (subtract-points (view-size view) #@(2 2))))
  70.           (#_EraseRect r)
  71.           (with-fore-color (or (part-color view :frame) *black-color*)
  72.             (#_FrameRect r)))
  73.         (rlet ((r :rect 
  74.                   :topleft #@(2 2) 
  75.                   :bottomright (add-points #@(2 2) (i-size view))))
  76.           (with-fore-color (or (part-color view :foreground) *black-color*)
  77.             (if (color-p view)
  78.               (#_plotCicon r (nth (icon-num view) (icons view)))
  79.               (#_ploticon r (nth (icon-num view) (icons view)))))) ))
  80.     (draw-pop-up-triangle view) ))
  81.  
  82.  
  83. (defmethod draw-pop-up-triangle ((view select-icon-button))
  84.   (let* ((top (- (ceiling (point-v (i-size view)) 2) 3))
  85.          (bottom (+ top 10))
  86.          (left (- (point-h (view-size view)) 9))
  87.          (right (+ left 5))
  88.          (middle (floor (+ top bottom) 2)))
  89.     (with-focused-view view
  90.       (with-fore-color (or (part-color view :frame) *black-color*)
  91.         (with-port (wptr view) (setf (view-get view 'my-poly) (#_OpenPoly)))
  92.         (#_Moveto left top)
  93.         (#_Lineto right middle)
  94.         (#_Lineto left bottom)
  95.         (#_Lineto left top)
  96.         (let ((poly (view-get view 'my-poly)))
  97.           (with-port (wptr view) (#_ClosePoly))
  98.           (#_PaintPoly poly)
  99.           (#_KillPoly poly) )) )))
  100.  
  101.  
  102. (defmethod view-click-event-handler ((view select-icon-button) where)
  103.   (declare (ignore where))
  104.   (let ((old-item (icon-num view))
  105.         (new-item (puv-select-icon view view)))
  106.     (when (and new-item (not (equal old-item new-item)))
  107.       (set-selected-icon view new-item)
  108.       (dialog-item-action view))))
  109.  
  110.  
  111. (defmethod remove-view-from-window ((view select-icon-button))
  112.   (call-next-method)
  113.   (pusiv-destroy view))
  114.  
  115.  
  116. (defmethod selected-icon ((view select-icon-button))
  117.   (let ((len (1- (length (icon-nicknames view)))))
  118.     (if (>= len (icon-num view))
  119.       (nth (icon-num view) (icon-nicknames view))
  120.       (icon-num view))))
  121.  
  122.  
  123. (defmethod set-selected-icon ((view select-icon-button) n)
  124.   (cond ((and (numberp n) (<= 0 n (1- (length (icons view)))))
  125.          (setf (icon-num view) n)
  126.          (invalidate-view view))
  127.         ((member n (icon-nicknames view))
  128.          (setf (icon-num view) (position n (icon-nicknames view)))
  129.          (invalidate-view view))
  130.         (t (error "Invalid icon number: ~s, supplied to select icon button." n)) ))
  131.  
  132.  
  133. (provide :select-icon-button)
  134.  
  135. #|
  136.  
  137. (puv-init)
  138. ; (puv-destroy)
  139.  
  140. (setf w (make-instance 'window
  141.           :color-p t
  142.           :view-subviews
  143.           (list (make-instance 'select-icon-button
  144.                   :color-p nil
  145.                   :selected-icon 'note
  146.                   :icons '((0 stop) (1 note) (2 alert))     
  147.                   :icon-size #@(32 32)
  148.                   :view-position #@(20 20)
  149.                   :color-list (list :selection *orange-color*
  150.                                     :foreground *brown-color*
  151.                                     :background *yellow-color*
  152.                                     :shadow *green-color*)))))
  153.  
  154. |#